home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / marks.tcl < prev    next >
Encoding:
Text File  |  2000-10-05  |  6.6 KB  |  271 lines
  1. #  AlphaTcl - core Tcl engine
  2. # ================================================================================
  3. # Marks for front window.
  4. #================================================================================
  5.  
  6. proc namedMarkProc {menu item} {
  7.     switch -- $item {
  8.     "markFile"            {markFile; message "File marked."}
  9.     "set"                 {setNamedMark}
  10.     "goto"                {gotoFileMark}
  11.     "remove"            {removeNamedMark}
  12.     "sort"                {sortMarksFile}
  13.     "sortByPosition"    {orderMarks}
  14.     }
  15. }
  16.  
  17. proc unnamedMarkproc {menu item} {
  18.     switch -- $item {
  19.     "set"                     {setMark}
  20.     "exchangePointAndMark"    {exchangePointAndMark}
  21.     "hilite"                {markHilite}
  22.     }
  23. }
  24.     
  25.  
  26.  
  27. proc gotoFileMark {} {
  28.     set text [getSelect]
  29.     if {[string length $text] && ([string length $text] < 32)} {
  30.     gotoMark [listpick -p "Mark?" -L [list $text] [getNamedMarks -n]]
  31.     } else {
  32.     gotoMark [listpick -p "Mark?" [getNamedMarks -n]]
  33.     }
  34. }
  35.  
  36. proc markFile {} {
  37.     if {[llength [getNamedMarks -n]]} {
  38.     global quietlyClearMarks
  39.     if {$quietlyClearMarks || [dialog::yesno -c "Clear old marks?"]} {
  40.         removeAllMarks
  41.     }
  42.     }
  43.     mode::proc MarkFile
  44. }
  45.  
  46. proc ::MarkFile {} {
  47.     message "This mode does not support file marking."
  48. }
  49.  
  50. proc removeAllMarks {{pat *}} {
  51.     set win [win::Current]
  52.     if {![catch {
  53.     foreach mk [getNamedMarks -n] {
  54.         if {[string match $pat $mk]} {
  55.         removeNamedMark -w $win -n $mk
  56.         }
  57.     } 
  58.     }]} { 
  59.     return
  60.     }
  61.     # some marks contain curly braces!
  62.     # (This will be fixed in Alpha8)
  63.     foreach mk [quote::Regfind [getNamedMarks -n]] {
  64.     if {[string match $pat $mk]} {
  65.         removeNamedMark -w $win -n $mk
  66.     }
  67.     if {[string index $mk 0] == "\{"} {
  68.         set mk [string range $mk 1 [expr {[string length $mk] -1}]]
  69.     }
  70.     if {[string match $pat $mk]} {
  71.         removeNamedMark -n $mk -w $win
  72.     }
  73.     }
  74. }
  75.  
  76. proc clearFileMarks {} {removeAllMarks}
  77.  
  78. proc sortMarksFile {} {
  79.     if {![dialog::yesno "Really sort all marks?"]} {return}
  80.     
  81.     set nm [win::Current]
  82.     
  83.     set mks {}
  84.     foreach mk [getNamedMarks] {
  85.     removeNamedMark -n [lindex $mk 0] -w [lindex $mk 1]
  86.     lappend mks $mk
  87.     }
  88.     
  89.     foreach mk [lsort $mks] {
  90.     set name [lindex $mk 0]
  91.     set disp [lindex $mk 2]
  92.     set pos [lindex $mk 3]
  93.     set end [lindex $mk 4]
  94.     
  95.     setNamedMark $name $disp $pos $end
  96.     }
  97. }
  98.  
  99. # From Mark Nagata.  Once we have Tcl 8, we can get rid
  100. # of this and use 'lsort -index 0 -dictionary' below.
  101. proc zeroadd {num} {
  102.     set mx [maxPos]
  103.     set len [string length $mx]
  104.     set num [format "%0${len}d" $num]
  105.     return $num
  106. }
  107.  
  108. proc orderMarks {} {
  109.     if {![dialog::yesno "Really reorder all marks?"]} {return}
  110.     
  111.     set nm [win::Current]
  112.     
  113.     set wks {}
  114.     foreach mk [getNamedMarks] {
  115.     removeNamedMark -n [lindex $mk 0] -w $nm
  116.     set name [lindex $mk 0]
  117.     set disp [lindex $mk 2]
  118.     set pos [lindex $mk 3]
  119.     set end [lindex $mk 4]
  120.     set pos [zeroadd $pos]
  121.     set wk [list $pos $disp $name $end]
  122.     lappend wks $wk
  123.     }
  124.     
  125.     foreach wk [lsort $wks] {
  126.     set name [lindex $wk 2]
  127.     set disp [lindex $wk 1]
  128.     set pos [lindex $wk 0]
  129.     set end [lindex $wk 3]
  130.     
  131.     setNamedMark $name $disp $pos $end
  132.     }
  133. }
  134.  
  135.  
  136. # ================================================================================
  137. # Simple mark stack implementation
  138. # ================================================================================
  139.  
  140. proc placeBookmark {{msg 1}} {
  141.     global markStack
  142.     global markName
  143.     
  144.     set name mark$markName
  145.     incr markName
  146.     createTMark $name [getPos]
  147.     set fileName [win::Current]
  148.     set markStack [linsert $markStack 0 [list $fileName $name [getPos]]]
  149.     if {$msg} {
  150.     message "Placed bookmark \#[llength $markStack]"
  151.     }
  152. }
  153.  
  154. proc returnToBookmark {{msg 1}} {
  155.     global markStack
  156.     if {[llength $markStack] == "0"} {
  157.     message "No bookmarks have been placed!"
  158.     return
  159.     }
  160.     set mark [lindex $markStack 0]
  161.     set markStack [lreplace $markStack 0 0]
  162.     if {[lsearch -exact [winNames -f] [lindex $mark 0]] == -1} {
  163.     # Window has since been closed
  164.     file::openQuietly [win::StripCount [lindex $mark 0]]
  165.     goto [lindex $mark 2]
  166.     } else {
  167.     # Window is still open
  168.     global alpha::platform
  169.     if {${alpha::platform} == "tk"} {
  170.         # In Alphatk right now marks are not recorded globally;
  171.         # they depend on having the correct window open and in front.
  172.         bringToFront [lindex $mark 0]
  173.     }
  174.     if {[catch {gotoTMark [lindex $mark 1]}]} {
  175.         returnToBookmark
  176.         return
  177.     }
  178.     }
  179.     if {$msg} {
  180.     message "Returned to bookmark \#[expr {[llength $markStack] + 1}]"
  181.     }
  182. }
  183.  
  184. # Used to create a popup of all funcs in window. Routine 
  185. # should return list containing, consecutively, proc name and
  186. # start of definition. 
  187. proc parseFuncsAlpha {} {
  188.     mode::proc parseFuncs
  189. }
  190.  
  191. proc ::parseFuncs {} {
  192.     global sortFuncsMenu funcExpr parseExpr
  193.     if {![info exists funcExpr] || ! [info exists parseExpr]} {
  194.     # Give an informative error message
  195.     error "This mode doesn't have both 'funcExpr' and 'parseExpr'\
  196.       defined, so it can't use the default parseFuncs procedure."
  197.     }
  198.     set pos [minPos]
  199.     set m {}
  200.     if {$sortFuncsMenu} {
  201.     while {[set res [search -s -f 1 -r 1 -i 0 -n $funcExpr $pos]] != ""} {
  202.         if {[regexp -- $parseExpr [eval getText $res] dummy word]} {
  203.         lappend m [list $word [lindex $res 0]]
  204.         }
  205.         set pos [lindex $res 1]
  206.     }
  207.     set m [eval concat [lsort -ignore $m]]
  208.     } else {
  209.     while {[set res [search -s -f 1 -r 1 -i 0 -n $funcExpr $pos]] != ""} {
  210.         if {[regexp -- $parseExpr [eval getText $res] dummy word]} {
  211.         lappend m $word [lindex $res 0]
  212.         }
  213.         set pos [lindex $res 1]
  214.     }
  215.     }
  216.     return $m
  217. }
  218.  
  219. proc gotoFunc {} {
  220.     set l [parseFuncsAlpha]
  221.     if {[set ind [lsearch -exact $l "\(-"]] >= 0} {
  222.     array set pos [lrange $l [expr {$ind + 2}] end]
  223.     } else {
  224.     array set pos $l
  225.     }
  226.     set res [listpick -p "Func:" [lsort [array names pos]]]
  227.     goto $pos($res)
  228. }
  229.  
  230.  
  231. proc editMark {fname mname args} {
  232.     if {[winIsFile $fname]} {
  233.     set fname [file nativename $fname]
  234.     set pos [lsearch -exact [winNames -f] "$fname"]
  235.     } else {
  236.     set pos [lsearch [winNames -f] "*$fname*"]
  237.     }
  238.     if {$pos >= 0}  {
  239.         bringToFront [lindex [winNames -f] $pos]
  240.     if {[icon -q]} {
  241.         icon -o
  242.     } 
  243.     } else {
  244.         if {[lsearch $args {-r}] >= 0} {
  245.         edit -r "$fname"
  246.         } else {
  247.         edit "$fname"
  248.     }
  249.     }
  250.     set mNames [getNamedMarks -n]
  251.     if {[set closestFound [lsearch -glob $mNames "*${mname}*"]] < 0} {
  252.     catch {mode::proc MarkFile}
  253.     set mNames [getNamedMarks -n]
  254.     } 
  255.     if {[lsearch $mNames "${mname}"] >= 0} {
  256.         gotoMark $mname
  257.     } elseif {[lsearch $mNames " ${mname}"] >= 0} {
  258.     #this gets used when procName is indented in pop-up -tr
  259.         gotoMark " $mname"
  260.     } else {
  261.     if {$closestFound == -1} {
  262.         return 1
  263.     } else {
  264.         gotoMark [lindex $mNames $closestFound]
  265.     }
  266.     
  267.     }
  268.     return 0
  269. }
  270.  
  271.